(COMMENT THIS LISP COMPILER WAS WRITTEN BY STUART NELSON FOR THE
	 SIGMA7)

(DEFPROP SPECIAL
 (LAMBDA (X)
  (MAPC (FUNCTION (LAMBDA (Y) (PUTPROP Y T (QUOTE SPECIAL)))) X))
 FEXPR)

(SPECIAL DIRECT LOUT SPVARS AC SV LV PROGEXIT WORK AL ARGS GL)

(DEFPROP WHOLE
	 (LAMBDA NIL
		 (MAPC (FUNCTION COMPILE1)
		       (QUOTE (COMPILE1	CEVAL
					CLMB
					UNSTK
					SETSPEC
					SETLOC
					STKCLR
					CANDOR
					CRPOG
					CCOND
					OUTJ
					CGO
					OUTTAG
					IO
					PRINTTY
					CLIST
					LOCATE
					MOVE))))
	 EXPR)

(BAKGAG T)

(*RSET T)

(SETQ DIRECT NIL)

(SETQ BASE (SETQ IBASE 10.))

(SETQ THISPIECEOFCODEWASLOST NIL)


(DEFPROP COMPILE1
 (LAMBDA (NAME)
  (PROG (EXP FLAG LV SV TEM AL AC ARGS SPVARS EXIT LOUT WORK)
	(COND ((NULL (SETQ TEM (GETL NAME (QUOTE (EXPR FEXPR)))))
	       (PRINTTY	(CONS NAME
			      (QUOTE (IS NOT AN EXPR OR FEXPR))))
	       (RETURN NIL)))
	(SETQ FLAG (CDR	(ASSOC (CAR TEM)
			       (QUOTE ((EXPR . SUBR)
				       (FEXPR . FSUBR))))))
	(COND (DIRECT (LAP1))
	      (T (PRINT (LIST (QUOTE LAP) NAME FLAG))))
	(COND ((ZEROP (LENGTH (SETQ ARGS (CAR (SETQ EXP
						    (CDADR TEM))))))
	       (OI (QUOTE (PSW 1 6))))
	      (T (OI (QUOTE (BAL 4 SETUP)))))
	(SETLOC ARGS NIL)
	(SETQ AL (CONS (QUOTE *RTN) AL))
	(COND ((EQ (QUOTE PROG) (CAR (SETQ EXP (CADR EXP))))
	       (SETQ TEM (CPROG (CDR EXP) AL T))
	       (SETQ AL (CADDR TEM)))
	      (T (CEVAL EXP AL NIL)))
	(SETSPEC ARGS NIL NIL)
	(SETQ EXIT (QUOTE (RTN1 RTN2 RTN3 RTN4)))
	(COND ((NOT (EQ (QUOTE *Q) (CAR AL))) (GO B)))
   A	(COND ((EQ (QUOTE *S) (CAR (SETQ AL (CDR AL)))) (GO A)))
	(SETQ EXIT (CDDR EXIT))
   B	(COND ((NOT (EQ (QUOTE *RTN) (CAR AL)))
	       (MOVE (QUOTE LW) 1 (LOCATE (QUOTE *RTN)))
	       (SETQ EXIT (CDR EXIT))))
	(MOVE (QUOTE LI) 8 (LIST (MINUS (LENGTH AL))))
	(OUTJ (QUOTE B) (CAR EXIT))
	(COND ((NULL WORK) (RETURN NIL)))
	(MAPCAR (FUNCTION COMPILE1) WORK)))
 EXPR)


(DEFPROP CEVAL
 (LAMBDA (X AL TYPE)
  (PROG (FN Y LOC TAG NARG TEM TEM1)
   TOP	(COND ((ATOM X) (GO A)))
	(SETQ Y (CDR X))
	(COND ((ATOM (SETQ FN (CAR X))) (GO B))
	      ((EQ (CAR FN) (QUOTE LAMBDA)) (CLMB FN Y) (GO RET))
	      ((EQ (CAR FN) (QUOTE LABEL)) (GO D)))
   E	(CLIST Y T)
	(CEVAL FN AL NIL)
	(COND (Y (PULL (SETQ LOC 10)) (OI (QUOTE (XW 3 10))))
	      ((SETQ LOC 3)))
	(GO FNC)
   A	(COND ((OR (NUMBERP X) (MEMBER X (QUOTE (T NIL)))) (GO QT)))
	(MOVE (QUOTE LW) 3 (LOCATE X))
   RET	(COND ((ATOM TYPE) (RETURN NIL)))
	(RETURN	(OUTJ (COND ((CAR TYPE)	(SETQ AC (QUOTE (QUOTE NIL)))
					(QUOTE BNEZ))
			    (T (QUOTE BEZ)))
		      (CDR TYPE)))
   QT	(COND ((ATOM TYPE)
	       (COND ((NULL TYPE)
		      (MOVE (QUOTE LI)
			    3
			    (LIST (LIST (QUOTE QUOTE) X))))))
	      ((CAR TYPE) (COND (X (GO BOUT))))
	      ((NULL X) (GO BOUT)))
   XIT	(RETURN NIL)
   BOUT	(SETQ TAG (CDR TYPE))
   BOUT1(RETURN (OUTJ (QUOTE B) TAG))
   B	(COND ((NOT (SETQ TEM (GETL FN
				    (QUOTE (MACRO FEXPR
						  FSUBR
						  EXPR
						  SUBR
						  LSUBR
						  SPECIAL)))))
	       (PRINTTY (LIST FN (QUOTE UNDEFINED)))
	       (GO SBR))
	      ((MEMBER (SETQ TEM1 (CAR TEM)) (QUOTE (EXPR SUBR)))
	       (GO SBR))
	      ((MEMBER TEM1 (QUOTE (FEXPR FSUBR))) (GO FSBR))
	      ((EQ TEM1 (QUOTE LSUBR)) (GO LSBR))
	      ((EQ TEM1 (QUOTE MACRO)) (SETQ X (APPLY (CADR TEM) X))
				       (GO TOP)))
	(SETQ LOC (CAR (LOCATE FN)))
	(GO H)
   SBR	(COND ((MEMBER FN (QUOTE (NOT NULL)))
	       (COND ((NOT TYPE) (GO H))
		     ((EQ TYPE T) (GO XIT))
		     (T	(SETQ TYPE (CONS (NOT (CAR TYPE))
					 (CDR TYPE)))
			(SETQ X (CAR Y))
			(GO TOP))))
	      ((EQ FN (QUOTE RETURN)) (CEVAL (CAR Y) AL NIL)
				      (SETQ TAG PROGEXIT)
				      (GO BOUT1)))
   H	(CLIST Y NIL)
	(SETQ NARG (LENGTH Y))
   FNC	(OI (LIST (QUOTE CALL)
		  NARG
		  (COND	(LOC (LIST (QUOTE *) LOC))
			(T (LIST (QUOTE :FN) FN)))))
	(GO RET)
   LSBR	(CLIST Y T)
	(MOVE (QUOTE LI) 3 (LIST (MINUS (LENGTH Y))))
	(SETQ NARG 14)
	(GO FNC)
   FSBR	(COND ((EQ FN (QUOTE QUOTE)) (SETQ X (CAR Y)) (GO QT))
	      ((EQ FN (QUOTE SETQ))
	       (CEVAL (CADR Y) AL NIL)
	       (MOVE (QUOTE STW) 3 (LOCATE (CAR Y)))
	       (GO RET))
	      ((EQ FN (QUOTE COND)) (CCOND Y TYPE) (GO RET))
	      ((EQ FN (QUOTE GO))
	       (COND ((NOT (EQ TYPE T)) (PRINTTY X)))
	       (SETQ TAG (CGO (CAR Y)))
	       (GO BOUT1))
	      ((EQ FN (QUOTE FUNCTION))
	       (COND ((NOT (ATOM (SETQ X (CAR Y))))
		      (PUTPROP (SETQ X (CAR (SETQ WORK (CONS (GENSYM)
							     WORK))))
			       (CAR Y)
			       (QUOTE EXPR))))
	       (GO QT))
	      ((EQ FN (QUOTE AND)) (SETQ TEM NIL) (GO ANDOR))
	      ((EQ FN (QUOTE OR)) (SETQ TEM T) (GO ANDOR))
	      ((EQ FN (QUOTE PROG)) (CPROG Y AL NIL) (GO RET)))
   F	(CEVAL (CONS (QUOTE QUOTE) Y) AL NIL)
	(SETQ NARG 15)
	(GO FNC)
   ANDOR(COND ((NULL Y) (SETQ X (NOT TEM)) (GO QT)))
	(CANDOR Y AL TYPE TEM)
	(GO XIT)
   D	(SETQ X	(LIST (LIST (QUOTE LAMBDA)
			    (LIST (CADR FN))
			    (CONS (CADR FN) Y))
		      (LIST (QUOTE QUOTE) (CADDR FN))))
	(GO TOP)))
 EXPR)


(DEFPROP CLMB
 (LAMBDA (FN Y)
  (PROG (T1 T2 T3 T4 T5)
	(SETQ T1 AL)
	(CLIST Y T)
	(COND ((GREATERP (SETQ T2 (DIFFERENCE (SETQ T3
					       (LENGTH (SETQ T5
							(CADR FN))))
					      (SETQ T4 (LENGTH Y))))
			 0)
	       (STKCLR T2)))
	(SETQ AL T1)
	(SETLOC T5 NIL)
   CL	(COND ((MINUSP T2) (SETQ T2 (ADD1 T2))
			   (SETQ AL (CONS (QUOTE *Z) AL))
			   (GO CL)))
	(SETQ T2 (SETSPEC T5 NIL NIL))
	(CEVAL (CADDR FN) AL NIL)
	(COND (T2 (OI (QUOTE (BAL 1 UNBIND)))))
	(UNSTK (MAX T3 T4))))
 EXPR)

(DEFPROP UNSTK
 (LAMBDA (N)
	 (COND ((NOT (ZEROP N))	(MOVE (QUOTE LI) 4 (LIST (MINUS N)))
				(OI (QUOTE (MSP 4 6)))
				(OI (QUOTE (AI 3))))))
 EXPR)

(DEFPROP SETSPEC
 (LAMBDA (L I P)
  (PROG (V T1)
   A	(COND ((NULL L)	(COND (V (SETQ AL (CONS (QUOTE *Q) AL))))
			(RETURN V))
	      ((GET (SETQ T1 (CAR L)) (QUOTE SPECIAL)) (GO B)))
   C	(SETQ L (CDR L))
	(GO A)
   B	(COND ((NULL V)	(COND (I (SETQ AL (CDR AL)))
			      (T (OI (QUOTE (BAL 4 SPECBIND)))))))
	(OI (LIST (LSH (COND (P 1) (T (CAR (LOCATE T1)))) 14)
		  0
		  (LIST (QUOTE :SPEC) T1)))
	(SETQ V (SETQ AL (CONS (QUOTE *S) AL)))
	(GO C)))
 EXPR)


(DEFPROP SETLOC
 (LAMBDA (L P)
	 (PROG (T1 N)
	       (SETQ N 0)
	  A    (COND ((NULL L) (RETURN N)))
	       (SETQ T1 (CAR L))
	       (COND ((AND P (GET T1 (QUOTE SPECIAL))) (GO B)))
	       (SETQ AL (CONS T1 AL))
	       (SETQ N (ADD1 N))
	  B    (SETQ L (CDR L))
	       (GO A)))
 EXPR)

(DEFPROP STKCLR
 (LAMBDA (N)
  (COND	((EQUAL N 1) (OI (QUOTE (LI 3))) (OI (QUOTE (PSW 3 6))))
	(T (MOVE (QUOTE LI) 2 (LIST N)) (OI (QUOTE (BAL 1 STZ))))))
 EXPR)

(DEFPROP CANDOR
 (LAMBDA (X AL TYPE FL)
  (PROG (EXIT ST)
	(SETQ EXIT (GENSYM))
   A	(SETQ ST (CAR X))
	(COND ((NULL (SETQ X (CDR X))) (GO B))
	      (TYPE (CEVAL ST
			   AL
			   (CONS FL
				 (COND ((AND (NOT (ATOM TYPE))
					     (EQ (CAR TYPE) FL))
					(CDR TYPE))
				       (T EXIT))))
		    (GO A)))
	(CEVAL ST AL NIL)
	(OUTJ (COND (FL (QUOTE BNEZ)) (T (QUOTE BEZ))) EXIT)
	(GO A)
   B	(CEVAL ST AL TYPE)
	(OUTTAG EXIT)))
 EXPR)


(DEFPROP CPROG
 (LAMBDA (X AL LEVEL)
  (PROG (LVF SVF PROGEXIT GL T1 ST)
	(COND ((NOT (ZEROP (SETQ LVF (SETLOC (SETQ ST (CAR X)) 1))))
	       (STKCLR LVF)))
	(COND (LEVEL (SETSPEC ARGS NIL NIL)))
	(SETQ SVF (SETSPEC ST (AND LEVEL SV) 1))
	(SETQ PROGEXIT (GENSYM))
   A	(COND ((NULL (SETQ X (CDR X))) (GO B))
	      ((ATOM (SETQ ST (CAR X)))
	       (COND ((GET (SETQ T1 (CGO ST)) (QUOTE DEF))
		      (PRINTTY (LIST ST (QUOTE MDEF)))))
	       (COND ((GET (SETQ T1 (CGO ST)) (QUOTE DEF))
		      (PRINTTY (LIST ST (QUOTE MDEF)))))
	       (PUTPROP T1 T (QUOTE DEF))
	       (OUTTAG T1))
	      (T (CEVAL ST AL T)))
	(GO A)
   B	(COND ((OR (ATOM LOUT) (NOT (EQ (CAR LOUT) (QUOTE B))))
	       (OI (QUOTE (LI 3)))))
	(OUTTAG PROGEXIT)
	(COND (LEVEL (RETURN (LIST LVF SVF AL)))
	      (SVF (OI (QUOTE (BAL 1 UNBIND)))))
	(UNSTK LVF)))
 EXPR)


(DEFPROP CCOND
 (LAMBDA (Y TYPE)
  (PROG (EXIT ST NT FTAG)
	(SETQ ST (SETQ EXIT (GENSYM)))
   A	(COND ((NULL Y) (GO B)))
	(SETQ NT (CAR Y))
	(SETQ Y (CDR Y))
	(SETQ FTAG (GENSYM))
	(COND ((NULL NT) (GO A)))
	(SETQ ST (CAR NT))
	(COND ((NULL (SETQ NT (CDR NT)))
	       (CEVAL ST AL NIL)
	       (COND (Y (OUTJ (QUOTE BNEZ) EXIT)))
	       (GO A))
	      ((AND (NULL (CDR NT)) (EQ (CAAR NT) (QUOTE GO)))
	       (CEVAL ST AL (CONS T (CGO (CADAR NT))))
	       (GO A)))
	(CEVAL ST AL (CONS NIL FTAG))
   C	(SETQ ST (CAR NT))
	(COND ((SETQ NT (CDR NT)) (CEVAL ST AL T) (GO C)))
	(CEVAL ST AL (EQ TYPE T))
	(SETQ ST (AND (NOT (EQ TYPE T)) FTAG (GET FTAG (QUOTE REF))))
	(COND ((AND (OR	THISPIECEOFCODEWASLOST
			(NOT (EQ (CAR LOUT) (QUOTE B))))
		    (OR Y ST))
	       (OUTJ (QUOTE B) EXIT)))
	(OUTTAG FTAG)
	(GO A)
   B	(COND (ST (OI (QUOTE (LI 3)))))
	(OUTTAG EXIT)))
 EXPR)

(DEFPROP OUTJ
 (LAMBDA (INST TAG) (OI (LIST INST 0 (PUTPROP TAG TAG (QUOTE REF)))))
 EXPR)

(DEFPROP CGO
 (LAMBDA (LV)
  (CDR (SASSOC LV
	       GL
	       (FUNCTION (LAMBDA NIL
			  (CAR (SETQ GL	(CONS (CONS LV (GENSYM))
					      GL))))))))
 EXPR)

(DEFPROP OUTTAG
 (LAMBDA (TAG) (COND ((GETL TAG (QUOTE (DEF REF))) (OI TAG))))
 EXPR)


(DEFPROP OI
 (LAMBDA (X)
	 (PROG NIL
	       (SETQ LOUT X)
	       (COND (DIRECT (LAPWRD X)) (T (PRINT X)))
	       (COND ((OR (ATOM X)
			  (NOT (MEMBER (CAR X) (QUOTE (BEZ BNEZ)))))
		      (SETQ AC NIL)))))
 EXPR)

(DEFPROP PRINTTY (LAMBDA (X) (PRINT X)) EXPR)

(DEFPROP CLIST
 (LAMBDA (Y DLF)
  (PROG NIL
   A	(COND ((NULL Y) (RETURN AL)))
	(CEVAL (CAR Y) AL NIL)
	(COND ((OR (CDR Y) DLF)	(OI (QUOTE (PSW 3 6)))
				(SETQ AL (CONS (QUOTE *T) AL))))
	(SETQ Y (CDR Y))
	(GO A)))
 EXPR)

(DEFPROP LOCATE
	 (LAMBDA (X)
		 (PROG (TP N)
		       (COND ((MEMBER X SPVARS) (GO A)))
		       (SETQ TP AL)
		       (SETQ N 0)
		  B    (COND ((NULL TP) (GO C))
			     ((EQ X (CAR TP)) (RETURN (LIST N 6))))
		       (SETQ N (SUB1 N))
		       (SETQ TP (CDR TP))
		       (GO B)
		  C    (COND ((NOT (GET X (QUOTE SPECIAL)))
			      (PRINTTY (LIST X (QUOTE UNDECLARED)))))
		       (SETQ SPVARS (CONS X SPVARS))
		       (PUTPROP X T (QUOTE SPECIAL))
		  A    (RETURN (LIST (LIST (QUOTE :SPEC) X)))))
	 EXPR)

(DEFPROP MOVE
 (LAMBDA (INST REG X)
  (COND	((NOT (EQUAL AC (CAR X))) (OI (CONS INST (CONS REG X)))
				  (SETQ AC (CAR X)))))
 EXPR)